\ disasm v1.1 05.4.12 NAB
\ ported from JForth
\  (Mike Haas 1/92)
\ Edited by JCF.

needs core-ext
needs case
needs systraps

module disasm

: disassembler
  get-order nip  [ get-current ] literal
   swap set-order ;

0 value palmostrap
2variable dism-base
: +b dism-base 2@ rot m+ ;

: w@ ( a -- x )  +b @a ;
: b@ ( a -- byte )  +b c@a ;
: l@ ( a -- x. )  +b 2@a ;

false value show-cycles

0 value approx
: approximate  true to approx ;
: exact  false to approx ;
0 value dism-adr
0 value dism-size
0 value dism-done
0 value high-branch
0 value start-adr
0 value doing-call?
: doing-call  true to doing-call? ;
: not-doing-call  false to doing-call? ;
0 value op
: byte>cell ( byte -- n )
    [ (hex) 4887 cs, ] \ ext.w d7
; inline
\  255 and dup
\ 127 > if 127 invert or then ;

: >flag ( bool -- flag )  0<> ;

: bits ( n offset bits -- bits-of-n )
  >r rshift  -1 r> lshift invert and ;

: bit-set? ( n bit -- flag )
  1 swap lshift and >flag ;

: op-bits ( off #bits -- n )
  op rot rot bits ;

: op-bit? ( bit# -- flag )
  op swap bit-set? ;

: op-btst ( bit# -- )
    :
    swap [compile] literal
    ['] op-bit? compile,
    [compile] ;
;

8 op-btst 8?
7 op-btst 7?
6 op-btst 6?
5 op-btst 5?
3 op-btst 3?

: 1|2 ( true -- 2 | false -- 1 )
    1 and 1+ \ must be proper flag
;

: 6&7 ( -- 6&7 )  6 2 op-bits ;
: 6&7? ( -- flag )  6&7 3 = ;

: op>>9 ( -- op>>9 )  op 9 rshift ;
: op>>3 ( -- op>>3 )  op 3 rshift ;

: a2+  dism-adr cell+ align to dism-adr ;

: param dism-adr cell+ w@ ;

: .# ( -- )  ." #" ;

: ., ( -- )  ." ," ;

: bin.# ( -- )
  base @ ." #%" param 0 .r a2+  base ! ;

: set-size ( -- )
  6 2 op-bits to dism-size ;
: >arg space ;

: size$
  s" bwl?" drop swap chars +
  [char] . emit 1 type space ;

: .size  dism-size 3 min size$ ;

: .long 2 size$ ;
: .word 1 to dism-size 1 size$ ;
: .byte 0 size$ ;

: .base-char
  base @ case
   2 of ." %" endof
  16 of ." $" endof
  endcase ;

\ Cycle-counting; incomplete [NAB]
: done? ; \ stub
: +long drop ; \ stub
: +cycles drop ; \ stub
: +mem drop ; \ stub
: +if-long 2drop ; \ stub
: is-mem ; \ stub

: .imm .# .base-char
  dism-adr cell+ dism-size
  case 0 of 1+ b@ byte>cell 0 endof
    1 of w@ 0 endof
    2 of l@ a2+ endof
    3 of w@ 0 endof
  endcase a2+ 0 d.r  4 +long ;

: .areg  ." a" 7 and [char] 0 + emit ;
: .dreg  ." d" 7 and [char] 0 + emit ;

: .( ." (" ;
: .) ." )" ;
: .an .areg ;
: .a@ .( .areg .) 4 +cycles is-mem ;
: .a@+ .( .areg ." )+" 4 +cycles is-mem ;
: .-a@ ." -(" .areg .) 6 +cycles is-mem ;
: .num .base-char 0 .r ;

: .dw ( -- )
  palmostrap if
  ." dc.w $" base @
  hex >arg op dup u. cr .systrap
  base !
  false to palmostrap
  else
   ." dc.w" >arg op .num
  then
;

: .param-size ( -- )
  param 11 bit-set?
  if  .long  else  .word  then ;

: .called-name? ( xt -- )
  doing-call? if ."  = " .name else drop then ;

: .args-reladr ( adr -- )
  dism-adr tuck - + bl emit ( .num ) u. ;

: .,r)
  ., param 12 3 bits param 15 bit-set?
  if .areg else .dreg  then .param-size .) ;

: .an+w ( op -- ) param .num .a@
  dism-adr cell+ w@
  .called-name?
  a2+ 4 +long is-mem
;

: .param param byte>cell .num ;

include disasm.part2
include disasm.part3
include disasm.part4
end-module
